home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d12 / ddj1190.arc / E_FLOYD.ARC / SPELCHEK.PAS < prev    next >
Pascal/Delphi Source File  |  1990-10-27  |  16KB  |  477 lines
  1. {$A+,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V+}
  2. {$M 6144,0,655360}
  3. Program SpelChek;
  4. { SPELCHEK - A spelling checker.  Copyright 1990 by Edwin T. Floyd. }
  5. Uses Dos, Crt, Dict;
  6.  
  7. Const
  8.   Alphabetic = ['a'..'z','A'..'Z']; { Alphabetic characters }
  9.   WordChar = Alphabetic+[''''];   { Default WordSet }
  10.   DefaultOutput = '';             { Default output filename (''=stdout) }
  11.   BufSize = 4096;                 { I/O buffer size }
  12.  
  13. Type
  14.   FileEntryPtr = ^FileEntry;
  15.   FileEntry = Record
  16.   { Input file name list entry }
  17.     NextFile : FileEntryPtr;
  18.     FileName : PathStr;
  19.   End;
  20.  
  21. Var
  22.   FileList, LastFile : FileEntryPtr;   { File name list }
  23.   WordCount : LongInt;                 { Total number of words examined }
  24.   BadWords : LongInt;                  { Total number of words not found }
  25.   OldMem : LongInt;                    { Original value of MemAvail }
  26.   ReturnCode : Word;                   { Return code for Halt }
  27.   WordSet : Set Of Char;               { Words are made of these }
  28.   dab, dcd, deh, din, dor, dst, duz, user : Dictionary;
  29.   TextFile : File;                     { Input file }
  30.   OutFile : Text;                      { Output file }
  31.   HighOrder : Boolean;                 { If true, clear high-order bits }
  32.   FullMark : Boolean;                  { If true, output full markup info }
  33.   UserDict : Boolean;                  { If true, use a user dictionary }
  34.   SuppressOutput : Boolean;            { If true, do not write output file }
  35.   Aborted : Boolean;                   { True if operator aborted }
  36.   OutName : PathStr;                   { Output file name }
  37.   UserDictName : PathStr;              { User dictionary name }
  38.   DictPath : PathStr;                  { Dictionary path }
  39.   TextBuf : Array[1..BufSize] Of Char; { I/O buffer for TextFile }
  40.  
  41. {$S+}
  42. Function ProcessParameter(s : String) : Boolean; Forward;
  43.  
  44. Function ParseParamString(s : String) : Boolean;
  45. { Extract parameters from a string and process them; return True if all OK. }
  46. Var
  47.   i, j : Word;
  48.   ParamsOk : Boolean;
  49. Begin
  50.   ParamsOk := True;
  51.   While (s <> '') And (s[Length(s)] = ' ') Do Dec(s[0]);
  52.   While s <> '' Do Begin
  53.     i := 1;
  54.     While (i <= Length(s)) And (s[i] = ' ') Do Inc(i);
  55.     j := Succ(i);
  56.     While (j <= Length(s)) And (s[j] <> ' ') Do Inc(j);
  57.     If Not ProcessParameter(Copy(s, i, j - i)) Then ParamsOk := False;
  58.     Delete(s, 1, Pred(j));
  59.   End;
  60.   ParseParamString := ParamsOk;
  61. End;
  62.  
  63. Function ProcessParameter(s : String) : Boolean;
  64. { Process command line parameter or file name; return True if OK. }
  65. Var
  66.   ThisFile : FileEntryPtr;
  67.   IncludeFile : Text;
  68.   ParamOk : Boolean;
  69.   i, j : Word;
  70.   IoRes : Integer;
  71. Begin
  72.   ParamOk := True;
  73.   If (s[1] = '-') Or (s[1] = '/') Then Case UpCase(s[2]) Of
  74.     'H' : If s[3] = '-' Then HighOrder := False Else HighOrder := True;
  75.     'M' : If s[3] = '-' Then FullMark := False Else FullMark := True;
  76.     'O' : Begin { Output file }
  77.       Delete(s, 1, 2);
  78.       For i := 1 To Length(s) Do s[i] := UpCase(s[i]);
  79.       If (s <> '') And ((s[1] = '-') Or (s = 'NUL')) Then Begin
  80.         SuppressOutput := True;
  81.         OutName := '-';
  82.       End Else Begin
  83.         SuppressOutput := False;
  84.         If s = '' Then OutName := s Else OutName := FExpand(s);
  85.       End;
  86.     End;
  87.     'P' : Begin { Dictionary path }
  88.       Delete(s, 1, 2);
  89.       For i := 1 To Length(s) Do s[i] := UpCase(s[i]);
  90.       If (s <> '') Then Begin
  91.         DictPath := FExpand(s);
  92.         If DictPath[Length(DictPath)] <> '\' Then DictPath := DictPath + '\';
  93.       End Else DictPath := s;
  94.     End;
  95.     'U' : Begin { User dictionary }
  96.       Delete(s, 1, 2);
  97.       For i := 1 To Length(s) Do s[i] := UpCase(s[i]);
  98.       If (s <> '') And ((s[1] = '-') Or (s = 'NUL')) Then Begin
  99.         UserDict := False;
  100.         UserDictName := '';
  101.       End Else Begin
  102.         UserDict := True;
  103.         UserDictName := FExpand(s);
  104.       End;
  105.     End;
  106.     'W' : Begin { Word character set }
  107.       Delete(s, 1, 2);
  108.       Case s[1] Of
  109.         '+' : ;
  110.         '-' : WordSet := [];
  111.         Else Begin
  112.           WriteLn('WordSet (-W) option must be followed by + or -.');
  113.           ParamOk := False;
  114.         End;
  115.       End;
  116.       Delete(s, 1, 1);
  117.       For i := 1 To Length(s) Do
  118.         WordSet := WordSet + [s[i]];
  119.     End;
  120.     Else Begin
  121.       WriteLn('Unrecognized option: ', s);
  122.       ParamOk := False;
  123.     End;
  124.   End Else If s[1] = '@' Then Begin
  125.     Delete(s, 1, 1);
  126.     For i := 1 To Length(s) Do s[i] := UpCase(s[i]);
  127.     Assign(IncludeFile, s);
  128.     Reset(IncludeFile);
  129.     IoRes := IoResult;
  130.     If IoRes = 0 Then Begin
  131.       WriteLn('Processing include file ', s);
  132.       Repeat
  133.         ReadLn(IncludeFile, s);
  134.         IoRes := IoResult;
  135.         If IoRes = 0 Then If Not ParseParamString(s) Then ParamOk := False;
  136.       Until Eof(IncludeFile) Or (IoRes <> 0);
  137.       If IoRes <> 0 Then Begin
  138.         WriteLn('Error ', IoRes, ' reading include file');
  139.         ParamOk := False;
  140.       End;
  141.       Close(IncludeFile);
  142.       IoRes := IoResult;
  143.     End Else Begin
  144.       WriteLn('Error ', IoRes, ' opening include file ', s);
  145.       ParamOk := False;
  146.     End;
  147.   End Else Begin
  148.     New(ThisFile);
  149.     If ThisFile <> Nil Then Begin
  150.       With ThisFile^ Do Begin
  151.         NextFile := Nil;
  152.         FileName := FExpand(s);
  153.       End;
  154.       If LastFile = Nil Then FileList := ThisFile
  155.       Else LastFile^.NextFile := ThisFile;
  156.       LastFile := ThisFile;
  157.     End;
  158.   End;
  159.   ProcessParameter := ParamOk;
  160. End;
  161.  
  162. Procedure ParseParams;
  163. { Interpret environment and command line parameters; display Help info. }
  164. Var
  165.   i, j : Word;
  166.   ParamsOk : Boolean;
  167.   Ch : Char;
  168.   s : String;
  169. Begin
  170.   WriteLn('SPELCHEK v1.0 - A spelling checker.  Copyright 1990 by Edwin T. Floyd.');
  171.   ParamsOk := True;
  172.   If Not ParseParamString(GetEnv('SPELCHEK')) Then Begin
  173.     WriteLn('Error found in SET SPELCHEK=.. environment string');
  174.     ParamsOk := False;
  175.   End;
  176.   For i := 1 To ParamCount Do Begin
  177.     FillChar(s[1], 255, ' ');
  178.     s := ParamStr(i);
  179.     If Not ProcessParameter(s) Then ParamsOk := False;
  180.   End;
  181.   If Not ParamsOk Then Begin
  182.     WriteLn('At least one parameter was in error.  Run SPELCHEK with no parameters');
  183.     WriteLn('to see documentation.');
  184.     Halt(1);
  185.   End Else If FileList = Nil Then Begin
  186.     WriteLn;
  187.     WriteLn('  SPELCHEK filenames.. [-H] [-W[+/-]abc..] [@name] [-Oname] [-Ppath]' );
  188.     WriteLn('                       [-Uname]');
  189.     WriteLn;
  190.     WriteLn('All command line parameters are separated by spaces.  Input text filenames');
  191.     WriteLn('and options may be intermixed; options are distinguished by a leading hyphen:');
  192.     WriteLn;
  193.     WriteLn('  -H[-] Clear high-order bits on input file (i.e. WordStar, default off).');
  194.     WriteLn('  -M[-] Output markup information for MARKDOC program');
  195.     WriteLn('  -W-abc.. Replace the word character set with the indicated characters');
  196.     WriteLn('     (default is all alphabetic characters, upper and lower case, apostrophe).');
  197.     WriteLn('  -W+abc.. Add additional characters to the word character set.');
  198.     WriteLn('  -O[name] Name the output file (default is name omitted => stdout).');
  199.     WriteLn('  -O- Suppress output (counts are still displayed on screen).');
  200.     WriteLn('  -Ppath Drive and directory of dictionary files.');
  201.     WriteLn('  -Uname specifies a user dictionary.');
  202.     WriteLn;
  203.     WriteLn('The "@" prefixes the name of an ASCII include file which may contain');
  204.     WriteLn('filenames, options, and nested include files, in any order.');
  205.     Write('Press any key to continue...');
  206.     Ch := ReadKey;
  207.     Write(^M);
  208.     ClrEol;
  209.     WriteLn;
  210.     WriteLn('You may use the DOS "SET" command to specify default parameters.  Examples:');
  211.     WriteLn;
  212.     WriteLn('  SET SPELCHEK=-Ospell.out -W-ABCDEFGHIJKLMNOPQRSTUVWXYZ');
  213.     WriteLn('  SET SPELCHEK=@defaults.spl -O -Pc:\spell');
  214.     WriteLn;
  215.     WriteLn('Command line parameters override "SET" parameters.  SPELCHEK examples:');
  216.     WriteLn;
  217.     WriteLn('  SPELCHEK document.txt -W+- -Obadwords.lst');
  218.     WriteLn('  SPELCHEK @filename.lst -Pc:\spell\dict -Obadwords.txt');
  219.     WriteLn('  SPELCHEK file1.txt -H+ -M+ -Umedterm.dct -O | MARKDOC');
  220.     WriteLn;
  221.     WriteLn('SPELCHEK was written by:');
  222.     WriteLn;
  223.     WriteLn('  Edwin T. Floyd         [76067,747]  (CompuServe)');
  224.     WriteLn('  #9 Adams Park Court    404/576-3305 (work)');
  225.     WriteLn('  Columbus, GA 31909     404/322-0076 (home)');
  226.     Halt(0);
  227.   End Else Begin
  228.     s := '';
  229.     If HighOrder Then ch := '+' Else ch := '-';
  230.     s := s + ' -H' + ch;
  231.     If FullMark Then ch := '+' Else ch := '-';
  232.     s := s + ' -M' + ch;
  233.     WriteLn('Options: ', s, ', -O', OutName);
  234.     If DictPath <> '' Then WriteLn('  -P', DictPath);
  235.     If UserDict Then WriteLn('  -U', UserDictName);
  236.     WriteLn('Press <Esc> to stop.');
  237.   End;
  238. End;
  239.  
  240. {$S-}
  241.  
  242. Function FileExists(FileName : PathStr) : Boolean;
  243. { Return TRUE if FileName can be opened ($F parameter should be off). }
  244. Var
  245.   f : File;
  246. Begin
  247.   Assign(f, FileName);
  248.   Reset(f);
  249.   If IoResult = 0 Then Begin
  250.     FileExists := True;
  251.     Close(f);
  252.   End Else FileExists := False;
  253. End;
  254.  
  255. Procedure LoadDict;
  256. { Load dictionaries }
  257. Var
  258.   d : DirStr;
  259.   n : NameStr;
  260.   e : ExtStr;
  261.   found : Boolean;
  262. Begin
  263.   If Not FileExists(DictPath+'AB.DCT') Then Begin
  264.     found := False;
  265.     If DictPath <> '' Then Begin
  266.       WriteLn('Dictionary not found in directory ', DictPath);
  267.       DictPath := '';
  268.       If FileExists('AB.DCT') Then found := True
  269.       Else WriteLn('Dictionary not found in current directory');
  270.     End;
  271.     If Not found Then Begin
  272.       FSplit(ParamStr(0), d, n, e);
  273.       If d[Length(d)] <> '\' Then d := d + '\';
  274.       DictPath := d;
  275.       If Not FileExists(DictPath+'AB.DCT') Then Begin
  276.         WriteLn('Dictionary not found in program directory');
  277.         WriteLn('Unable to locate master dictionary, terminating');
  278.         Halt(1);
  279.       End;
  280.     End;
  281.   End;
  282.   WriteLn('Loading dictionary');
  283.   dab.RestoreDictionary(DictPath+'AB.DCT');
  284.   dcd.RestoreDictionary(DictPath+'CD.DCT');
  285.   deh.RestoreDictionary(DictPath+'EH.DCT');
  286.   din.RestoreDictionary(DictPath+'IN.DCT');
  287.   dor.RestoreDictionary(DictPath+'OR.DCT');
  288.   dst.RestoreDictionary(DictPath+'ST.DCT');
  289.   duz.RestoreDictionary(DictPath+'UZ.DCT');
  290.   If UserDict Then Begin
  291.     If FileExists(UserDictName) Then Begin
  292.       WriteLn('Loading user dictionary');
  293.       user.RestoreDictionary(UserDictName)
  294.     End Else Begin
  295.       WriteLn('User dictionary not found: ', UserDictName);
  296.       WriteLn('Processing continued without user dictionary');
  297.     End;
  298.   End;
  299. End;
  300.  
  301. Function InDict(Var s : String) : Boolean;
  302. { Test for word in dictionary }
  303. Var
  304.   IsIn : Boolean;
  305. Begin
  306.   Case s[1] Of
  307.     'A'..'B' : IsIn := dab.StringInDictionary(s);
  308.     'C'..'D' : IsIn := dcd.StringInDictionary(s);
  309.     'E'..'H' : IsIn := deh.StringInDictionary(s);
  310.     'I'..'N' : IsIn := din.StringInDictionary(s);
  311.     'O'..'R' : IsIn := dor.StringInDictionary(s);
  312.     'S'..'T' : IsIn := dst.StringInDictionary(s);
  313.     'U'..'Z' : IsIn := duz.StringInDictionary(s);
  314.     Else IsIn := False;
  315.   End;
  316.   If UserDict And Not IsIn Then IsIn := user.StringInDictionary(s);
  317.   InDict := IsIn;
  318. End;
  319.  
  320. Function ParseInputBlock(Block : LongInt; Len : Word) : Word;
  321. { Check words from input block against dictionaries }
  322. Var
  323.   Words : Word;
  324.   s : String;
  325.   i, start : Word;
  326. Begin
  327.   i := 1;
  328.   Words := 0;
  329.   While i <= Len Do Begin
  330.     s := '';
  331.     While (i <= Len) And Not (TextBuf[i] In WordSet) Do Inc(i);
  332.     start := i;
  333.     If i <= Len Then Begin
  334.       Inc(Words);
  335.       While (i <= Len) And (Length(s) < 255)
  336.       And (TextBuf[i] In WordSet) Do Begin
  337.         Inc(s[0]);
  338.         s[Ord(s[0])] := UpCase(TextBuf[i]);
  339.         Inc(i);
  340.       End;
  341.       While (s <> '') And Not (s[1] In Alphabetic) Do Begin
  342.         Delete(s, 1, 1);
  343.         Inc(start);
  344.       End;
  345.       While (s <> '') And Not (s[Length(s)] In Alphabetic) Do
  346.         Dec(s[0]);
  347.  
  348.       { Check for posessive and for some contractions }
  349.       If s = 'WON''T' Then s := ''
  350.       Else If Length(s) > 3 Then Begin
  351.         If Copy(s, Length(s)-1, 2) = '''S' Then
  352.           Delete(s, Length(s)-1, 2)
  353.         Else If Copy(s, Length(s)-1, 2) = '''M' Then
  354.           Delete(s, Length(s)-1, 2)
  355.         Else If Copy(s, Length(s)-2, 3) = 'N''T' Then
  356.           Delete(s, Length(s)-2, 3)
  357.         Else If Copy(s, Length(s)-2, 3) = '''LL' Then
  358.           Delete(s, Length(s)-2, 3)
  359.         Else If Copy(s, Length(s)-2, 3) = '''RE' Then
  360.           Delete(s, Length(s)-2, 3)
  361.         Else If Copy(s, Length(s)-2, 3) = '''VE' Then
  362.           Delete(s, Length(s)-2, 3);
  363.       End;
  364.       If (Length(s) > 1) And Not InDict(s) Then Begin
  365.         Inc(BadWords);
  366.         If Not SuppressOutput Then Begin
  367.           If FullMark Then Write(OutFile, Block + start, ' ');
  368.           WriteLn(OutFile, s);
  369.         End;
  370.       End;
  371.     End;
  372.   End;
  373.   ParseInputBlock := Words;
  374. End;
  375.  
  376. Procedure ProcessNextFile;
  377. { Open and process the next input file pointed to by FileList. }
  378. Var
  379.   ThisFile : FileEntryPtr;
  380.   FileWords, BlockOfs, OldBad : LongInt;
  381.   i, MaxLen, Len : Word;
  382.   FileResult : Integer;
  383. Begin
  384.   ThisFile := FileList;
  385.   With ThisFile^ Do Begin
  386.     Write(FileName, ': ');
  387.     Assign(TextFile, FileName);
  388.     Reset(TextFile, 1);
  389.     FileResult := IoResult;
  390.     If FileResult = 0 Then Begin
  391.       If FullMark And Not SuppressOutput Then
  392.         WriteLn(OutFile, '0 ', FileName);
  393.       Len := 0;
  394.       FileWords := 0;
  395.       OldBad := BadWords;
  396.       BlockOfs := 0;
  397.       Repeat
  398.         BlockRead(TextFile, TextBuf[Succ(Len)], BufSize-Len, i);
  399.         FileResult := IoResult;
  400.         If FileResult = 0 Then Begin
  401.           MaxLen := Len + i;
  402.           If HighOrder Then For i := Len To MaxLen Do
  403.             TextBuf[i] := Chr(Ord(TextBuf[i]) And $7F);
  404.           Len := MaxLen;
  405.           If Not Eof(TextFile) Then Begin
  406.             While (Len > 0) And (TextBuf[Len] In WordSet) Do Dec(Len);
  407.             If (Len = 0) Then Len := MaxLen;
  408.           End;
  409.           FileWords := FileWords + ParseInputBlock(BlockOfs, Len);
  410.           BlockOfs := BlockOfs + Len;
  411.           MaxLen := MaxLen - Len;
  412.           If MaxLen > 0 Then
  413.             Move(TextBuf[Succ(Len)], TextBuf[1], MaxLen);
  414.           Len := MaxLen;
  415.           Write(^M, FileName, ': ', FileWords, ' words, ',
  416.             BadWords-OldBad, ' bad');
  417.           While KeyPressed Do If ReadKey = ^[ Then Aborted := True;
  418.         End;
  419.       Until Eof(TextFile) Or (FileResult <> 0) Or Aborted;
  420.       Close(TextFile);
  421.       WriteLn(^M, FileName, ': ', FileWords, ' words, ',
  422.         BadWords-OldBad, ' bad');
  423.       WordCount := WordCount + FileWords;
  424.     End Else WriteLn('Unable to open input file ', FileName);
  425.     If FileResult <> 0 Then Begin
  426.       WriteLn('Error ', FileResult);
  427.       Inc(ReturnCode);
  428.     End;
  429.     FileList := NextFile;
  430.   End;
  431.   Dispose(ThisFile);
  432. End;
  433.  
  434. {$F+}
  435. Function HandleHeapError(Size : Word) : Integer;
  436. Begin
  437.   WriteLn('SPELCHEK ran out of memory.');
  438.   Halt(1);
  439. End;
  440. {$F-}
  441.  
  442. Begin
  443.   HeapError := @HandleHeapError;
  444.   FileMode := $40;
  445.   FileList := Nil;
  446.   LastFile := Nil;
  447.   HighOrder := False;
  448.   FullMark := False;
  449.   UserDict := False;
  450.   SuppressOutput := False;
  451.   Aborted := False;
  452.   OutName := DefaultOutput;
  453.   UserDictName := '';
  454.   DictPath := '';
  455.   WordSet := WordChar;
  456.   WordCount := 0;
  457.   BadWords := 0;
  458.   ReturnCode := 0;
  459.   ParseParams;
  460.   LoadDict;
  461.   If Not SuppressOutput Then Begin
  462.     Assign(OutFile, OutName);
  463.     Rewrite(OutFile);
  464.   End;
  465.   While (FileList <> Nil) And Not Aborted Do ProcessNextFile;
  466.   If Aborted Then Begin
  467.     WriteLn('File processing aborted by operator');
  468.     If Not SuppressOutput Then WriteLn(OutFile, '***ABORTED***');
  469.     Inc(ReturnCode);
  470.   End;
  471.   If Not SuppressOutput Then Close(OutFile);
  472.   WriteLn('Final Counts: ', WordCount, ' words examined, ',
  473.     BadWords, ' words not found in dictionary');
  474.   WriteLn('Done!');
  475.   Halt(ReturnCode);
  476. End.
  477.